#!/usr/bin/perl -w
#####################################################################
#   StylePal: An advisor for scientific writing
#   Copyright (C) 2002-2003 Sven Rahmann
#
#   This program is free software; you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation; either version 2 of the License, or
#   (at your option) any later version.
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this program; if not, write to the Free Software
#   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307.
#####################################################################
use strict;
use Getopt::Std;

my $TITLE = <<ENDOFTITLE;
#####################################################################
#  Style.pl ("StylePal") v2003-Jan-16, (c) 2002 Sven Rahmann.
#
#  StylePal comes with ABSOLUTELY NO WARRANTY; see the GNU General
#  Public License for details. This is free software, and you are
#  welcome to redistribute it under certain conditions; see the
#  GNU General Public License for details.
#####################################################################
ENDOFTITLE

my $USAGE = <<ENDOFUSAGE;
#####################################################################
#  StylePal is an advisor for scientific writing.
#  It can be used in addition to or instead of GNU diction.
#  See the README file for further information.
#  Please send comments to: Sven.Rahmann @ molgen.mpg.de
#
#  USAGE:  Style.pl  [options]  file(s...)
#  Output options:
#    -h ("help")      Print this information; ignore any input
#    -t ("terse")     Print only line numbers with suggestions;
#                       normally the corresponding line is echoed.
#    -d ("DEBUG")     Print the matched pattern in curly braces
#  Pattern inclusion/exclusion options:
#    -w ("weak auxs") Complain about weak auxiliary verbs like 'might'
#    -f ("of of")     Complain about accumulation of 'of's
#    -p ("passive")   Complain about usage of passive voice
#    -i ("infos")     Print infos about occasionally misused words
#    -o ("only")      Exclude standard patterns (-po is passive only)
#####################################################################
ENDOFUSAGE


# Global Options
my $verbose;
my $debug;
#####################################################################

sub load_spl_file  #($fname, $display, $patref, $dispref)
  # Append all patterns and infotexts in file named "$fname"
  # to the hash %$patref, and the corresponding display status
  # to the hash %$dispref
  {
    my $fname   = shift;
    my $display = shift;
    my $patref  = shift;
    my $dispref = shift;
    my $ef = "Error in library file $fname";
    my ($p,$t);
    my $num=0;
    if ($debug) { print STDERR "Reading $fname: "; }
    open SPL,"< $fname" or die("$ef (file not found)");
    while (<SPL>)
      {
        # Read pattern, info-text, empty line
        $p=$_; chomp($p);
        eval { "" =~ /$p/ };
        if ($@) { die "$ef (invalid pattern /$p/)"; }
        $t=<SPL>; chomp($t);
        $num++;
        if ((exists $$patref{$p}) && !($$patref{$p} eq $t))
          { die "$ef (pattern /$p/ exists with different text)"; }
        $$patref{$p}=$t;
        $$dispref{$p}=$display;
        if (!eof) {
          if (!(<SPL> eq "\n")) {
            die "$ef (missing blank line between patterns)"; }}
      }
    close(SPL);
    if ($debug) {print STDERR "$num patterns\n";}
  }
#####################################################################

sub load_spls #($libs,$patref,$dispref)
  # Load all spl (style pattern library) files
  # according to $libs into $patref and $dispref
  # $libs many contain any of:
  #  s  standard
  #  p  passive
  #  f  of-of
  #  w  weak auxiliary verbs
  #  i  additional information
  {
    my $libs    = shift;
    my $patref  = shift;
    my $dispref = shift;
    my $path;
    if ($0 =~ /(.*)\/(.*)/s)
      { $path = $1; } else { $path='.'; }
    if ($libs =~ /:s:/)  # Load standard patterns
      {
        load_spl_file("$path/spell.spl",'s',$patref,$dispref);
        load_spl_file("$path/words.spl",'s',$patref,$dispref);
        load_spl_file("$path/abbrv.spl",'s',$patref,$dispref);
        load_spl_file("$path/repeats.spl",'s',$patref,$dispref);
        load_spl_file("$path/punct.spl",'s',$patref,$dispref);
        load_spl_file("$path/math.spl",'s',$patref,$dispref);
        load_spl_file("$path/passive.spl",'p',$patref,$dispref);
        load_spl_file("$path/weak-aux.spl",'w',$patref,$dispref);
        load_spl_file("$path/ofof.spl",'f',$patref,$dispref);
      }
    if ($libs =~ /:p:/) # Passive
      {
        load_spl_file("$path/passive.spl",'p',$patref,$dispref);
      }
    if ($libs =~ /:f:/) # Passive
      {
        load_spl_file("$path/ofof.spl",'f',$patref,$dispref);
      }
    if ($libs =~ /:w:/) # Weak auxiliary
      {
        load_spl_file("$path/weak-aux.spl",'w',$patref,$dispref);
      }
    if ($libs =~ /:i:/) # Additional info
      {
        load_spl_file("$path/info.spl",'i',$patref,$dispref);
      }
    if ($libs =~ /:X:/) # Test???
      {
        load_spl_file("$path/untested.spl",'X',$patref,$dispref); # Test
      }
  }

#####################################################################

sub deTeX # ($text)
  # Remove some latex commands from the text "$text"
  {
    my $text = shift;
    $text =~ s/\\\\(\[[^\]]*\])?//ig;    # Remove all line breaks (\\[2ex])
    $text =~ s/\\begin\{(equation|align)\*?\}/ \$/ig;
    $text =~ s/\\begin\{[^\}]*\}//ig;    # Remove all other begin's
    $text =~ s/\\end\{[^\}]*\}//ig;      # Remove all end's
    $text =~ s/\\\[/\$/ig;               # Replace all \[  ==> $ 
    $text =~ s/\\\]//ig;                 # Remove all \] 
    $text =~ s/~+/ /g;                   # Replace all ~ by spaces
    return $text;
  }

#####################################################################

sub byrange # for sorting by line number range
  {
    my ($c,$d);
    if ($a =~ /(\d+)-(\d+)/) {$c=$1+(($2-$1)/1000);} else {$c=$a;}
    if ($b =~ /(\d+)-(\d+)/) {$d=$1+(($2-$1)/1000);} else {$d=$b;}
    return ($c <=> $d);
  }

#####################################################################

sub process_file #($fname,$tref,$patref,$dispref,$libs)
# Arguments:
#   $fname
#   $reference-to-array-of-lines (text)
#   $reference-to-hash-of-patterns/infos
#   $reference-to-hash-of-patterns/display
#   $string with libraries-to-be-displayed
  {
    my $fname=shift;
    my $tref=shift;
    my $patref=shift;
    my $dispref=shift;
    my $libs=shift;

    # put an end-of-sentence at beginnig of text
    my $text=join '',  '. ',@$tref;
    my %pcount=();        # Pattern usage count
    my %suggestions=(); # Suggestions per line range
    my ($p,$pattern,$pc);
    my ($info,$tinfo);
    my $displayp;
    my ($this,$rest);
    my $dummy;
    my ($cpl1,$cpl2);
    my $cps;
    my $count;
    my $dline = "";
    my $infoline;
    my $textline;
    my $nl;
    my $fspace;
    my $ahints = "";

    # The whole text of the file is in $text
    # de-TeX if this is supposedly a .tex file
    $fspace=' ' x length($fname);
    if ($fname =~ /\.tex/) { $text=deTeX($text); }

    # Match each pattern $p against the text
    foreach $p (keys %$patref)
      {
        ($pattern=$p) =~ s/\s+/\[\\s,\.!;\]\+/g; # Modify and
        $pc = qr/$pattern/si;                    # compile pattern
        $this='!!THIS!!';
        $info=$$patref{$p};
        $info =~ s/\$Cr /Consider removing /g;      # Expand $Cr
        $info =~ s/\$Cc /Consider changing /g;      # Expand $Cc
        $info =~ s/\$Ao /Avoid overusing /g;        # Expand $Ao
        $info =~ s/\$Cus /Consider using simply /g; # Expand $Cus
        if ($@) {die "Error [$@] with /$p/ [$info]";}
        $displayp = ($libs =~ /:$$dispref{$p}:/);
        while ($text =~ /$pc/g)
          {
            $pcount{$p}++;
            next if (!$displayp);
            $this=substr($text, $-[0], $+[0]-$-[0]);
            $cps=""; $cpl1=0; $cpl2=0;
            $_=substr($text,0,$-[0]); $count = tr/\n/\n/ +1;
            if ($this =~ /^\S{0,3}[ \t\r\f]*(\s+)/) {
              $dummy=$1;
              $dummy =~ s/\n/{ $cpl1++ }/mge;
            }
            $this =~ s/\s+$//; $rest=$this;
            $this =~ s/^\s+//; $this =~ s/\s+/ /g;
            $rest =~ s/\n/{ $cpl2++ }/mge;
            $cpl2+=$count; $count+=$cpl1;
            $cps = ($cpl2-$count>0)?"$count-$cpl2":$count;
            if ($debug) { $dline = " \{$this\}"; }
            # Further massage $this for nicer display:
            $this =~ s/\W+$//;
            $this =~ s/^\W+//;
            $tinfo=$info;
            $tinfo =~ s/\$this/$this/ge; # Expand $this
            if ($verbose) { $infoline="  > $tinfo$dline\n"; }
            else {$infoline = "$fname:$cps: $tinfo\n"; }
            if (exists($suggestions{$cps}))
              { $suggestions{$cps} .= $infoline; }
            else {
              if ($verbose) {
                # Extract line #count from $text
                $textline=join(" ",@$tref[($count-1)..($cpl2-1)]);
                $textline =~ s/^\s+//;
                $textline =~ s/\s+$//;
                $textline =~ s/\s+/ /g;
                $suggestions{$cps}
                  = "$fname:$cps:\n[$textline]\n$infoline";
              }
              else { $suggestions{$cps} = $infoline; }
            }
          }
        # if this pattern is not displayed but occurs, generate warning
        if (!$displayp && $pcount{$p}) {
          $ahints .= "$fname: Using option '-$$dispref{$p}' would display ".
            "$pcount{$p} occurrence(s) of\n$fspace  \"$info\"\n";
        }
      }

    # Print suggestions per line; then additional hints
    $nl=0;
    foreach $count (sort byrange keys %suggestions) {
      print($suggestions{$count});
      if ($verbose) { print "\n"; }
      $nl=1;
    }
    if ($nl) { print "\n"; }
    if ($ahints) { print $ahints,"\n"; }

    # Return
  }
####################################################################


####################################################################
## MAIN
####################################################################
my %options;
my ($fname,$nextfname);
my @tlines;
my $libs;
my %patlist=();
my %displist=();

$TITLE =~ s/\#(  )?//g;
$USAGE =~ s/\#(  )?//g;
$USAGE =~ s/\n//;
print STDERR $TITLE;

getopts("dthopwfit", \%options);
if ($options{h}) { print STDERR $USAGE; exit;}
$debug=$options{d};
$verbose=!($options{t}) || $debug;

# Load all desired pattern libraries
$libs = ":s:";
if ($options{o}) { $libs =~ s/:s://g; }
if ($options{p}) { $libs.=":p:"; }
if ($options{w}) { $libs.=":w:"; }
if ($options{f}) { $libs.=":f:"; }
if ($options{i}) { $libs.=":i:"; }
if ($options{X}) { $libs.=":X:"; }
load_spls($libs,\%patlist,\%displist);

# Process all input files
$nextfname = $ARGV[0] || "stdin";
while (<>)
  {
    @tlines =($_);
    $fname=$nextfname;
    $nextfname=$ARGV[0];
    if (!eof)
      { while (<>) { push(@tlines,$_); last if (eof); } }

    # Whole text of current file is now in @tlines
    process_file($fname,\@tlines,\%patlist,\%displist,$libs);
    last if (!defined($nextfname));
  }
####################################################################

